COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 This program is henceforth called: ``SAIL constraint combinatorial pairing
C00011 ENDMK
C⊗;
;;; This program is henceforth called: ``SAIL constraint combinatorial pairing
;;; program'' or SCCPP.

;;;First, in SCCPP there are functions with 7 arguments. For example,
;;;the first function starts out:
;;;
;;;(DEFUN PAIRS 
;;;       (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;;	  NIL-PAIRS) ...)
;;;
;;;I suggest the following translation:
;;;
;;;(DEFUN PAIRS n
;;;       ((LAMBDA (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;;		  NIL-PAIRS) ...)
;;;	(ARG 1)(ARG 2)(ARG 3)(ARG 4)(ARG 5)(ARG 6)(ARG 7)))
;;;
;;;(*list a1 ... an) => (cons a1 (cons a2 ...(cons an-1 an)))
;;;
;;;(*catch x y) evaluates the form y. x should EVAL to a tag. If y returns
;;;normally, the value of the *catch is the value of y. If the evaluation
;;;of y entails the evaluation of a form like (*throw q v) where q EVALs
;;;to the same tag that x did, then v is evaluated and the value of the *catch
;;;is the value of v. Unless, there is an intervening *catch with the same
;;;tag...
;;;
;;;MAPCAN is MAPCAR with NCONC instead of CONS.
;;;
;;;1+, +, < etc are FIXNUM versions of ADD1, PLUS, LESSP etc.
;;;
;;;(FUNCALL fun x1 ... xn) evaluates all of its arguments and
;;;applies the value of fun to the arguments x1 ... xn. So
;;;(FOO a b c d) = (FUNCALL 'FOO a b c d)
;;;
;;;			-rpg-


(DEFUN PAIRS (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
	      NIL-PAIRS) 
       ((LAMBDA (XXX) 
	 (MAPCAN 
	  #'(LAMBDA (I) 
             (AND
	       (COND
		(MUST-APPEAR
		 (*CATCH 'OUT
		   (MAPC 
		    #'(LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR)
					 (*THROW 'OUT T)))) 
		   I)))
		(T))
	       (LIST I)))
	  XXX)) 
	(MAPCAR #'CDR
		(COND ((< (LENGTH X)
			  (+ (COND (NIL-PAIRS 1) (T 0)) (LENGTH Y)))
		       (PAIRS1 (MAKE-POSSIBILITY-1 X
						   Y
						   FUN
						   APPLY-CONSTRAINTS
						   CONSTRAINTS
						   NIL-PAIRS)))
		      (T (PAIRS2 (MAKE-POSSIBILITY-2 Y
						     X
						     FUN
						     APPLY-CONSTRAINTS
						     CONSTRAINTS
						     NIL-PAIRS)))))))


(DEFUN MAKE-POSSIBILITY-1 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
			   NIL-PAIRS) 
       ((LAMBDA (N) 
	 ((LAMBDA (Q) 
	   (COND
	    (NIL-PAIRS (MAPC #'(LAMBDA (I) (RPLACD I
						   (LIST* '(NIL)
							  (CDR I))))
			     Q))
	    (T Q)))
	  (MAPCAN 
	   #'(LAMBDA (I) 
		     (SETQ N 0)
		     ((LAMBDA (A) (AND A
				       (OR (NULL CONSTRAINTS)
					   (NULL APPLY-CONSTRAINTS)
					   (FUNCALL APPLY-CONSTRAINTS
						    CONSTRAINTS))
				       (LIST (LIST* I A))))
		(MAPCAN 
		 #'(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
				(PROGN (SETQ N (1+ N))
				       (COND ((OR (NULL FUN)
						  (FUNCALL FUN I J))
					      (LIST* N J))))))
		 Y)))
  	   X)))
	0))


(DEFUN MAKE-POSSIBILITY-2 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
			   NIL-PAIRS) 
       ((LAMBDA (N) 
	 ((LAMBDA (Q) 
	   (COND
	    (NIL-PAIRS (MAPC #'(LAMBDA (I) (RPLACD I
						   (LIST* '(NIL)
							  (CDR I))))
			     Q))
	    (Q)))
	  (MAPCAN 
	   #'(LAMBDA (I) 
	       (SETQ N 0)
	       ((LAMBDA (A) (AND A
				 (OR (NULL CONSTRAINTS)
				     (NULL APPLY-CONSTRAINTS)
				     (FUNCALL APPLY-CONSTRAINTS
					      CONSTRAINTS))
				 (LIST (LIST* I A))))
		(MAPCAN 
		 #'(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
				(PROGN (SETQ N (1+ N))
				       (COND ((OR (NULL FUN)
						  (FUNCALL FUN J I))
					      (LIST* N J))))))
		 Y)))
	   X)))
	0))


(DEFUN PAIRS1 (L) 
       (COND
	((NULL L) '((NIL)))
	(T
	 ((LAMBDA (CAND POSS) 
	   (MAPCAN 
	    #'(LAMBDA (PAIRS) 
		((LAMBDA (AVOID ANS) 
		  (MAPCAN 
		   #'(LAMBDA (I) 
			     ((LAMBDA (Q) (COND (Q (NCONS Q))))
			      (COND ((CAR (MEMBER (CAR I)
						  AVOID))
				     (LIST* AVOID ANS))
				    (T (LIST* (LIST* (CAR I)
						     AVOID)
					      (LIST* CAND
						     (CDR I))
					      ANS)))))
		   POSS))
		 (CAR PAIRS)
		 (CDR PAIRS)))
	    (PAIRS1 (CDR L))))
	  (CAAR L)
	  (CDAR L)))))


(DEFUN PAIRS2 (L) 
       (COND
	((NULL L) '((NIL)))
	(T
	 ((LAMBDA (CAND POSS) 
	   (MAPCAN 
	    #'(LAMBDA (PAIRS) 
		((LAMBDA (AVOID ANS) 
		  (MAPCAN 
		   #'(LAMBDA (I) 
			     ((LAMBDA (Q) (COND (Q (NCONS Q))))
			      (COND ((CAR (MEMBER (CAR I)
						  AVOID))
				     (LIST* AVOID ANS))
				    (T (LIST* (LIST* (CAR I)
						     AVOID)
					      (LIST* (CDR I)
						     CAND)
					      ANS)))))
		   POSS))
		 (CAR PAIRS)
		 (CDR PAIRS))) 
	    (PAIRS2 (CDR L))))
	  (CAAR L)
	  (CDAR L)))))

(declare (special a b))
(setq a '(
	  (1 2)
	  (7 8)
	  (9 0)
	  (a b c)
	  (a b c)
	  (d e f)
	  (d e f)
	  (g h i)
	  (g h i)
	  (j k l)
	  (m n o)
	  (p q r)
	  ))
(setq b '(
	  (a b c)
	  (j k l)
	  (d e f)
	  (p q r)
	  (g h i)
	  (9 0)
	  (a b c)
	  (p q r)
	  (7 8)
	  (j k l)
	  (2 1)
	  (3 2)
	  (8 7)
	  (9 8)
	  (0 9)
	  (m n o)
	  (d e f)
	  (j k l)
	  (m n o)
	  (d e f)
	  (p q r)
	  (g h i)
	  ))

(include "timer.lsp")

(timer timit 
       (pairs a b () 'equal () () ()))
;2592